home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Night Owl 6
/
Night Owl's Shareware - PDSI-006 - Night Owl Corp (1990).iso
/
020a
/
intgif11.zip
/
GIFUNIT.PAS
next >
Wrap
Pascal/Delphi Source File
|
1990-07-18
|
15KB
|
691 lines
{-------------------------------------------------------------------------}
{ }
{ GIFUnit v.1.0 - Copyright (c) EUROPA Software, 1990 - September 11 }
{ }
{-------------------------------------------------------------------------}
unit GIFUnit;
interface
uses dos;
const ValSig : array[1..3] of char = ('G','I','F');
Version87a : array[1..3] of char = ('8','7','a');
Version89a : array[1..3] of char = ('8','9','a');
NoYo : array[0..1] of string[3] = (' No', 'Yes');
Extensive = 3;
Medium = 2;
Short = 1;
BufferSize = 32768;
Sizes : array[1..3] of word = (1024, 32768, 32768);
crlf = #13 + #10;
tempfilename = 'qztp0ejf.ozp';
type gifheader = record
Sig : array[1..3] of char;
Ver : array[1..3] of char;
RWidth,
RHeight : word;
GFeature,
Resolution,
GlobalColorMap : byte; { As a byte, we can index into the }
{ Yes/No array for printout. }
Interlace,
GColorMapSize,
CodeSize,
GBitsPerPixel,
Background : byte;
IWidth,
IHeight,
LeftOfs,
TopOfs : word;
IFeature,
LocalColorMap,
IBitsPerPixel,
LColorMapSize : byte;
end;
type FileNodePtr = ^FileNode;
FileNode = RECORD
Name : string;
Date : longint;
Size : longint;
Next : FileNodePtr;
end;
type Buffer = array[1..BufferSize] of byte;
BuffPtr = ^Buffer;
var GifFile,
GIFOut : File;
GH : GifHeader;
Buf,
OutBuf : BuffPtr;
SaveExitProc : pointer;
recurse : boolean;
TermByte,
BlockSize,
ControlCode,
Detail, Extra : byte;
ImageBytes,
TotalLZW,
FileEnd,
TotalBufIdx,
TotalFiles,
NotGifs : longint;
ImageNumber,
BufIdx,
OutBufIdx,
BufEnd,
BSize,
Res : word;
FileHead,p,
DirHead,q : FileNodePtr;
Path,StartDir,
CurrentDir,
mask,
D,N,E : string[80];
ExtensionBlock,
CommentBlock,
ImageSeperator,
GIFTerminator : byte;
function Getbyte : byte;
function Getword : word;
function AtEOF : boolean;
function GetNames : word;
function IsAGIF : boolean;
function pad( s : string; x : byte ) : string;
function rightstr( x : longint; w : byte ) : string;
function Leading(st : string) : String;
function gooddate : string;
procedure PutByte( B : byte );
procedure PutWord( W : word );
procedure FlushBuffer;
procedure FillBuffer;
procedure ReadScreenDescriptor;
procedure ReadImageDescriptor;
procedure SkipExtensionBlock;
procedure SkipAndWriteExtensionBlock;
procedure blank(x : byte);
procedure AddToList( Name : string;
Date : longint;
Size : longint; var Head : FileNodePtr );
implementation
procedure FlushBuffer;
begin
blockwrite( GIFOut, OutBuf^, OutBufIdx, Res );
OutBufIdx := 0;
end;
procedure PutByte( B : byte );
begin
if OutBufIdx = BSize then FlushBuffer;
inc(OutBufIdx);
OutBuf^[OutBufIdx] := B;
end;
procedure PutWord( W : word );
begin
PutByte( lo(W) );
PutByte( hi(W) );
end;
procedure FillBuffer;
begin
blockread( GifFile, Buf^, BSize, BufEnd );
BufIdx := 1;
TotalBufIdx := TotalBufIdx + BufEnd;
end;
function Getbyte : byte;
var LByte : byte;
Begin
if BufIdx > BSize then FillBuffer;
Getbyte := Buf^[BufIdx];
inc(BufIdx);
End;
function Getword : word;
var A : byte;
B : word; { this is a WORD so that no precision is lost when }
{ the value is shifted into the High Byte of result }
Begin
A := Getbyte; { Remember LSB is first in the file stream, so B }
B := Getbyte; { is the high byte even though it comes last. }
GetWord := ((B shl 8) OR A);
End;
function GetAndPutbyte : byte;
var h : byte;
Begin
h := GetByte;
PutByte(h);
GetAndPutByte := h;
End;
function GetAndPutWord : Word;
var h : word;
begin
h := GetWord;
PutWord(h);
GetAndPutWord := h;
End;
procedure ReadScreenDescriptor;
var i : byte;
begin
for i := 1 to 3 do GH.Sig[i] := chr(getbyte);
for i := 1 to 3 do GH.Ver[i] := chr(getbyte);
GH.RWidth := getWord;
GH.RHeight := getWord;
GH.GFeature := getbyte;
if (GH.GFeature and $80) = $80 then
GH.GlobalColorMap := 1 else GH.GlobalColorMap := 0;
GH.Resolution := GH.GFeature and $70 shr 5 + 1;
GH.GBitsPerPixel := GH.GFeature and 7 + 1;
GH.Background := GetByte;
GH.GColorMapSize := 1 shl GH.GBitsPerPixel-1;
TermByte := GetByte;
If GH.GlobalColormap = 1 then
For I := 0 to GH.GColorMapSize do begin
TermByte := GetByte;
TermByte := GetByte;
TermByte := GetByte;
end;
end;
procedure ReadImageDescriptor;
var i : integer;
begin
inc(ImageNumber);
GH.Leftofs := GetWord;
GH.Topofs := GetWord;
GH.IWidth := GetWord;
GH.IHeight := GetWord;
GH.IFeature := GetByte;
if (GH.IFeature and 64) = 64 then
GH.Interlace := 1 else GH.Interlace := 0;
if (GH.IFeature and 128) = 128 then
GH.LocalColorMap := 1 else GH.LocalColorMap := 0;
GH.IBitsPerPixel := GH.IFeature and 7 + 1;
GH.LColorMapSize := 1 shl GH.IBitsPerPixel-1;
if GH.LocalColormap = 1 then
For i := 0 to GH.LColorMapSize do begin
TermByte := GetByte;
TermByte := GetByte;
TermByte := GetByte;
end;
end;
function AtEOF : boolean;
begin
AtEOF := ( FileEnd <= ((TotalBufIdx-BufEnd) + BufIdx -1) );
end;
procedure ExtensionBlockResults( z : byte );
begin
writeln(crlf + 'Extension Block Function Code: ', z, ' Requested.');
end;
procedure SkipExtensionBlock;
var ExtensionFunction,i : byte;
ExtensionSize : longint;
begin
ExtensionFunction := GetByte;
ExtensionSize := 0;
repeat
BlockSize := GetByte;
if BufIdx+256 < BufEnd then inc(BufIdx, BlockSize)
else for i := 1 to BlockSize do TermByte := GetByte;
inc(ExtensionSize, BlockSize);
until ((BlockSize = 0) OR (AtEOF));
TermByte := GetByte;
ExtensionBlockResults(ExtensionFunction);
end;
procedure ReadAndWriteScreenDescriptor;
var i : byte;
begin
for i := 1 to 3 do GH.Sig[i] := chr(getAndPutbyte);
for i := 1 to 3 do GH.Ver[i] := chr(getAndPutbyte);
GH.RWidth := getAndPutWord;
GH.RHeight := getAndPutWord;
GH.GFeature := getAndPutByte;
if (GH.GFeature and $80) = $80 then
GH.GlobalColorMap := 1 else GH.GlobalColorMap := 0;
GH.Resolution := GH.GFeature and $70 shr 5 + 1;
GH.GBitsPerPixel := GH.GFeature and 7 + 1;
GH.Background := GetAndPutByte;
GH.GColorMapSize := 1 shl GH.GBitsPerPixel-1;
TermByte := GetAndPutByte;
If GH.GlobalColormap = 1 then
For I := 0 to GH.GColorMapSize do begin
TermByte := GetAndPutByte;
TermByte := GetAndPutByte;
TermByte := GetAndPutByte;
end;
end;
procedure ReadAndWriteImageDescriptor;
var i : integer;
begin
inc(ImageNumber);
GH.Leftofs := GetAndPutWord;
GH.Topofs := GetAndPutWord;
GH.IWidth := GetAndPutWord;
GH.IHeight := GetAndPutWord;
GH.IFeature := GetAndPutByte;
if (GH.IFeature and 64) = 64 then
GH.Interlace := 1 else GH.Interlace := 0;
if (GH.IFeature and 128) = 128 then
GH.LocalColorMap := 1 else GH.LocalColorMap := 0;
GH.IBitsPerPixel := GH.IFeature and 7 + 1;
GH.LColorMapSize := 1 shl GH.IBitsPerPixel-1;
if GH.LocalColormap = 1 then
For i := 0 to GH.LColorMapSize do begin
TermByte := GetAndPutByte;
TermByte := GetAndPutByte;
TermByte := GetAndPutByte;
end;
end;
procedure SkipAndWriteExtensionBlock;
var ExtensionFunction,i : byte;
ExtensionSize : longint;
begin
ExtensionFunction := GetAndPutByte;
ExtensionSize := 0;
repeat
BlockSize := GetAndPutByte;
if BufIdx+256 < BufEnd then inc(BufIdx, BlockSize)
else for i := 1 to BlockSize do TermByte := GetAndPutByte;
inc(ExtensionSize, BlockSize);
until ((BlockSize = 0) OR (AtEOF));
TermByte := GetAndPutByte;
ExtensionBlockResults(ExtensionFunction);
end;
procedure AddToList( Name : string;
Date : longint;
Size : longint; var Head : FileNodePtr );
Var NewNode : FileNodePtr;
Done : Boolean;
ListNode : FileNodePtr;
Begin
new(NewNode);
if NewNode = NIL then begin
writeln('Not Enough Memory - Too many files!');
halt(1);
end;
NewNode^.Name := Name;
NewNode^.Date := Date;
NewNode^.size := Size;
NewNode^.Next := NIL;
If Head = NIL then Head := NewNode
else
If Name < Head^.Name then begin
NewNode^.Next := Head;
Head := NewNode;
end
else begin
Done := FALSE;
ListNode := Head;
While NOT Done do begin
If ListNode^.Next = NIL then begin
ListNode^.Next := NewNode;
Done := TRUE;
end
else
If ListNode^.Next^.Name > Name then begin
NewNode^.Next := ListNode^.Next;
ListNode^.Next := NewNode;
Done := TRUE;
end
else ListNode := ListNode^.Next;
end;
end;
end;
function GetNames : word;
Var F : SearchRec;
i : word;
Begin
FileHead := NIL;
i := 0;
FindFirst(mask, Archive, F);
While DosError = 0 do begin
inc(i);
AddToList(F.name, F.Time, F.Size, FileHead);
FindNext(F);
end;
GetNames := i;
end;
function IsAGIF : boolean;
const ErrMsg = ' is not a GIF file, or header is corrupt! Skipping.';
begin
IsAGIF := (GH.Sig = ValSig);
end;
procedure blank(x : byte);
var z : byte;
begin
for z := 1 to x do write(' ');
end;
function pad( s : string; x : byte ) : string;
var t : string;
begin
t := s;
while length(t) < x do t := t + ' ';
pad := t;
end;
function rightstr( x : longint; w : byte ) : string;
var st : string;
begin
str(x, st);
while length(st) < w do st := ' ' + st;
rightstr := st;
end;
procedure OneHeading;
const Head : array[1..2] of string =
(( ' Filename Horz Vert Col Global Map ' +
' Color Res. Date Stamp File Size' + crlf +
' -------- ---- ---- --- ---------- ' +
' ---------- ---------- ---------' ),
( ' Filename Horz Vert Col Global Map ' +
' Color Res. Images Lace LZW Bytes' + crlf +
' -------- ---- ---- --- ---------- ' +
' ---------- ------ ---- ---------' ));
begin
case Detail of
1,3 : write( crlf + Head[1] + crlf );
2 : write( crlf + Head[2] + crlf );
end;
end;
function Leading(st : string) : String;
var s : string;
begin
s := st;
if Length(s) = 1 then s := '0' + s;
Leading := s;
end;
function gooddate : string;
var dt : datetime;
Y,M,D : string;
begin
UnPackTime(p^.date, dt );
str(dt.Year, Y);
str(dt.Month, M);
str(dt.Day, D);
GoodDate := Leading(M) + '/' + Leading(D) + '/' + copy(Y,3,2);;
end;
begin
OutBufIdx := 0;
BSize := Sizes[3];
ExtensionBlock := 33;
CommentBlock := 254;
ImageSeperator := 44;
GIFTerminator := 59;
end.
